home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #14
/
Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO
/
netmail
/
txtq130.zip
/
ROBOQ.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-26
|
8KB
|
263 lines
{$M 10240,0,655360} { 10k reserved for data }
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
PROGRAM Convert_ROBOMAIL_Textfiles_to_QWK;
USES
DOS,
TXTQ;
VAR
SavedExitProc: POINTER;
{===========================================================================}
PROCEDURE CustomExit; FAR;
{---- Always exit through here ----}
BEGIN
ExitProc := SavedExitProc;
cursorOn;
Cleanup;
IF (ExitCode > 0) THEN BEGIN
WriteLn;
WriteLn ('ROBOQ - Free DOS utility: Convert Robomail "Text files" to QWK files.');
WriteLn (author);
WriteLn;
WriteLn ('Usage: ROBOQ <Robomail "Text file(s)"> (DOS wildcards are permitted.)');
WriteLn;
WriteLn ('Example: ROBOQ startrek.msg (creates "STARTREK.Q??")');
WriteLn;
END;
IF ErrorAddr <> NIL THEN
BEGIN
WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
WriteLn ('Address = ', Seg (ErrorAddr^), ':', Ofs (ErrorAddr^));
WriteLn ('Code = ', ExitCode);
ErrorAddr := NIL;
END
ELSE
IF (ExitCode > 0) AND (ExitCode < 255) THEN
WriteErr (ExitCode);
END;
FUNCTION GetMsgDate (datestr: STRING): STRING;
BEGIN
datestr [3] := #45; { replace '/' with '-' }
datestr [6] := #45;
GetMsgDate := datestr;
END;
FUNCTION GetMsgStat (MsgStat: CHAR): CHAR;
(* Note: the meaning of the status flag in the header of the QWK format
specification is interpreted differently by different products.
According to Patrick Y. Lee's "QWK Mail Packet File Layout" v1.0
and Robomail v1.30, an asterisk ('*') means private and received,
and the plus sign ('+') means private and NOT received.
SLMR, OLX, and SPEED seem to agree that the meaning of the two
symbols is reversed.
Since this is a Robomail utility, I've used the latter. Thus, the
private/ public flag will be translated into the following symbols:
public, unread = ' ' (#32)
private, unread = '+' (#43)
*)
BEGIN
IF MsgStat = 'u'
THEN GetMsgStat := #32 { unread, public }
ELSE GetMsgStat := #43; { unread, private }
END;
FUNCTION ExtractBBSname (dataline: STRING): STRING;
{Origin: CHANNEL1 - 0113 - Share}
BEGIN
IF (Pos (' - ', dataline) > 0) THEN
Delete (dataline, Pos (' - ', dataline), Length (dataline));
IF (Pos (#32, dataline) > 0) THEN
Delete (dataline, 1, Pos (#32, dataline));
ExtractBBSname := Trim (dataline);
END;
FUNCTION ExtractConfNumber (dataline: STRING): STRING;
{Origin: CHANNEL1 - 0113 - Share}
BEGIN
IF (Pos (' - ', dataline) > 0) THEN BEGIN
Delete (dataline, 1, 2 + Pos (' - ', dataline));
IF (Pos (' - ', dataline) > 0)
THEN dataline := Copy (dataline, 1, Pos (' - ', dataline) - 1)
ELSE dataline := '0';
END
ELSE
dataline := '0';
ExtractConfNumber := dataline;
END;
FUNCTION ExtractConfName (dataline: STRING): STRING;
{Origin: CHANNEL1 - 0113 - Share}
BEGIN
WHILE (Pos (' - ', dataline) > 0) DO
Delete (dataline, 1, 2 + Pos (' - ', dataline));
dataline := Trim (dataline);
IF dataline = '' THEN dataline := 'Unknown';
ExtractConfName := dataline;
END;
FUNCTION ReadMsgHeader (VAR MsgFile: FILE; VAR MsgNum: WORD): STRING;
CONST
hyphens = '-----------------------------------';
password = #32#32#32#32#32#32#32#32#32#32#32#32; { 12 spaces }
chunks = #32#32#32#32#32#32; { 6 spaces }
VAR
C_Line: STRING;
MsgFrom, MsgTo, subj: STRING [25];
MsgDate: STRING [8]; MsgTime: STRING [5];
MsgNumStr: STRING [7]; ReferN: STRING [8];
ConfNumb: STRING [5]; MsgStat: CHAR;
ConfName: STRING;
Count: BYTE;
BEGIN
REPEAT
ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
UNTIL (EoF (MsgFile)) OR (Copy (C_Line, 1, 8) = ('Origin: '));
IF EoF (MsgFile) THEN
ReadMsgHeader := ''
ELSE BEGIN
IF BBSname = '' THEN
BBSname := ExtractBBSname (C_Line);
ConfNumb := StrToDoubleChar (ExtractConfNumber (C_Line));
ConfName := ExtractConfName (C_Line);
AddConfToList (ConfNumb, ConfName);
AddMsgToList (ConfNumb, Blocks);
FOR count := 1 TO 2 DO BEGIN
ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
IF Copy (C_Line, 1, 7) = (' To:') THEN
MsgTo := RPad (Copy (C_Line, 9, Length (C_Line) - 8), 25, #32)
ELSE BEGIN
IF Copy (C_Line, 1, 7) = (' From:') THEN BEGIN
MsgFrom := Copy (C_Line, 9, 25);
MsgStat := GetMsgStat (C_Line [40]);
END;
END;
END;
ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
Verify (C_Line, ' Date:', 1);
MsgDate := GetMsgDate (Copy (C_Line, 9, 8));
MsgTime := Copy (C_Line, 21, 5);
ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
Verify (C_Line, ' Re:', 1);
subj := RPad (Copy (C_Line, 9, Length (C_Line) - 8), 25, #32);
ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
Verify (C_Line, hyphens, 1); {discard hyphen C_Line}
Inc (MSGnum);
Str (MSGnum, MsgNumStr);
MsgNumStr := RPad (MsgNumStr, 7, #32);
ReferN := RPad ('0', 8, #32);
ReadMsgHeader := (MsgStat + MsgNumStr + MsgDate+ MsgTime+ { 1+7+8+5 = 21 }
MsgTo + MsgFrom + subj + { 25+25+25 = 75 }
password + ReferN + chunks + #225 + { 12+8+6+1 = 27 }
ConfNumb + #0#0#42); { 2+3 = 5 }
END;
END;
{===========================================================================}
CONST SepLine = '<*>';
VAR
MSGnum : WORD;
Msgname: PATHSTR;
Msgext : EXTSTR;
Msgfile: FILE; DATfile : FILE;
Msgline: STRING; Message : MsgArray;
index, bytes, chunks: WORD;
Compressor : PATHSTR;
dirinfo : SEARCHREC; { contains filespec info. }
spath : PATHSTR; { source file path and }
sdir : DIRSTR; { directory }
filesdone : WORD;
BEGIN
SavedExitProc := ExitProc;
ExitProc := @CustomExit;
IF ParamCount <> 1
THEN Halt (255)
ELSE spath := GetFilePath (ParamStr (1), sDir);
FindFirst (spath, Archive, dirinfo);
filesdone := 0;
MkDir (TXTQ_DIR); CheckIO;
ChDir (TXTQ_DIR); CheckIO;
WHILE (DosError = 0) DO BEGIN
BBSname := '';
ConfList := NIL;
MsgList := NIL;
Conferences := 0;
MsgNum := 0;
Inc (filesdone);
Msgname := sdir + dirinfo. Name;
PrepareFiles (Msgname, Msgext, Msgfile, DATfile);
Blocks := 0;
Chunks := 2;
Msgline := SepLine;
REPEAT
IF (NOT EoF (Msgfile)) AND (RTrim (Msgline) = SepLine) THEN BEGIN
bytes := 0; updateCursor;
Inc (Blocks, chunks);
Msgline := ReadMsgHeader (Msgfile, MsgNum);
IF Msgline <> '' THEN BEGIN
WHILE (NOT EoF (Msgfile)) AND (RTrim (Msgline) <> SepLine) DO BEGIN
IF (bytes < MaxBytes) THEN
bytes := AddToArray (Message, bytes, Msgline);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
END;
IF (bytes > MaxBytes) THEN bytes := MaxBytes;
WHILE (Message [bytes] = #227) AND (Message [bytes - 1] = #227) DO
Dec (bytes);
index := AddToArray (Message, 116, FigureMSGsize (bytes, chunks));
IF (chunks > 1) THEN BEGIN
FOR index := (bytes + 1) TO (chunks * 128) DO
Message [index] := #32;
END;
BlockWrite (DATfile, Message, chunks * 128); CheckIO;
END
END
ELSE BEGIN
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard invalid lines}
END;
UNTIL EoF (Msgfile);
Close (Msgfile); CheckIO;
Close (DATfile); CheckIO;
WriteLn ('done!');
InitConfig (Compressor);
Write ('Compressing ', DATname, ' into ', Msgname, Msgext, ' ... ');
IF CompressDat (Msgname + Msgext, Compressor)
THEN WriteLn ('done!')
ELSE Halt (5);
FindNext (dirinfo);
END;
IF (filesdone = 0)
THEN Halt (1)
ELSE WriteLn ('Processed ', filesdone, ' file(s).');
END.